home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / CorePackages / aebuild.tcl next >
Encoding:
Text File  |  2000-11-22  |  15.5 KB  |  563 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  TclAE - Functions for building AppleEvents 
  4.  #              (modernization of appleEvents.tcl)
  5.  # 
  6.  #  FILE: "aebuild.tcl"
  7.  #                                    created: 12/13/99 {12:55:28 PM} 
  8.  #                                last update: 11/22/2000 {9:07:15 AM} 
  9.  #                                    version: 2.0
  10.  #  Author: Jonathan Guyer
  11.  #  E-mail: jguyer@his.com
  12.  #    mail: Alpha Cabal
  13.  #          POMODORO no seisan
  14.  #     www: http://www.his.com/jguyer/
  15.  #  
  16.  # ========================================================================
  17.  #               Copyright (c) 1999-2000 Jonathan Guyer
  18.  #                        All rights reserved
  19.  # ========================================================================
  20.  # Permission to use, copy, modify, and distribute this software and its
  21.  # documentation for any purpose and without fee is hereby granted,
  22.  # provided that the above copyright notice appear in all copies and that
  23.  # both that the copyright notice and warranty disclaimer appear in
  24.  # supporting documentation.
  25.  # 
  26.  # Jonathan Guyer disclaims all warranties with regard to this software,
  27.  # including all implied warranties of merchantability and fitness.  In
  28.  # no event shall Jonathan Guyer be liable for any special, indirect or
  29.  # consequential damages or any damages whatsoever resulting from loss of
  30.  # use, data or profits, whether in an action of contract, negligence or
  31.  # other tortuous action, arising out of or in connection with the use or
  32.  # performance of this software.
  33.  # ========================================================================
  34.  #  Description: 
  35.  # 
  36.  #  History
  37.  # 
  38.  #  modified   by  rev reason
  39.  #  ---------- --- --- -----------
  40.  #  1999-12-13 JEG 1.0 original
  41.  # ###################################################################
  42.  ##
  43.  
  44. # ◊◊◊◊ Initialization ◊◊◊◊ #
  45.  
  46. namespace eval tclAE::build {}
  47.  
  48. # ◊◊◊◊ Event handling ◊◊◊◊ #
  49.  
  50. ## 
  51.  # -------------------------------------------------------------------------
  52.  # 
  53.  # "tclAE::build::throw" --
  54.  # 
  55.  #  Shorthand routine to check for AppleEvent errors
  56.  # -------------------------------------------------------------------------
  57.  ##
  58. proc tclAE::build::throw {args} {
  59.     # Event is only parsed for error checking, so purge
  60.     # when done (in the event of an error, it'll already
  61.     # be gone).
  62.     tclAE::disposeDesc [eval tclAE::build::event $args]
  63. }
  64.  
  65. ## 
  66.  # -------------------------------------------------------------------------
  67.  # 
  68.  # "tclAE::build::event" --
  69.  # 
  70.  #  Encapsulation for new and old style event building.
  71.  # 
  72.  # Results:
  73.  #  The parsed result of the event.
  74.  # -------------------------------------------------------------------------
  75.  ##
  76. proc tclAE::build::event {args} {
  77.     global tclAEmodeVars
  78.     
  79.     # AE parsing is built into newer versions of Alpha
  80.     if {[set tclAEmodeVars(parseAppleEventsWithTcl)]} {
  81.         set event [eval tclAE::send -r -p $args]
  82.     } else {
  83.         set event [eval tclAE::send -r $args]
  84.         tclAE::parse::throwIfError $event
  85.     }
  86.     
  87.     return $event
  88. }
  89.  
  90. ## 
  91.  # -------------------------------------------------------------------------
  92.  # 
  93.  # "tclAE::build::resultData" --
  94.  # 
  95.  #  Shorthand routine to get the direct object result of an AEBuild call
  96.  # -------------------------------------------------------------------------
  97.  ##
  98. proc tclAE::build::resultData {args} {
  99.     global errorMsg
  100.     
  101.     set result ""
  102.     
  103.     set event [eval tclAE::build::event $args]
  104.     
  105.     if {[catch {set result [tclAE::getKeyData $event ----]} errorMsg]} {
  106.         if {![string match "Missing keyword '*' in record" $errorMsg]} {
  107.             # No direct object is OK
  108.             error::display
  109.         }        
  110.     } 
  111.     
  112.     tclAE::disposeDesc $event
  113.     
  114.     return $result
  115. }
  116.  
  117. ## 
  118.  # -------------------------------------------------------------------------
  119.  # 
  120.  # "tclAE::build::resultDesc" --
  121.  # 
  122.  #  Shorthand routine to get the direct object result of an AEBuild call,
  123.  #  retaining the type code
  124.  # -------------------------------------------------------------------------
  125.  ##
  126. proc tclAE::build::resultDesc {args} {
  127.     global errorMsg
  128.     
  129.     set result ""
  130.     
  131.     set event [eval tclAE::build::event $args]
  132.     
  133.     if {[catch {set result [tclAE::getKeyDesc $event ----]} errorMsg]} {
  134.         if {[string match "Missing keyword '*' in record" $errorMsg]} {
  135.             # No direct object is OK
  136.             set result ""
  137.         } else {
  138.             error::display
  139.         }        
  140.     } 
  141.     
  142.     tclAE::disposeDesc $event
  143.     
  144.     return $result
  145. }
  146.  
  147. ## 
  148.  # -------------------------------------------------------------------------
  149.  # 
  150.  # "tclAE::build::protect" --
  151.  # 
  152.  #  Alpha seems pickier about ident lengths than AEGizmos says it should be. 
  153.  #  Protect any whitespace.
  154.  # 
  155.  # Results:
  156.  #  Returns $value, possible bracketed with ' quotes
  157.  # 
  158.  # Side effects:
  159.  #  None.
  160.  # -------------------------------------------------------------------------
  161.  ##
  162. proc tclAE::build::protect {value} {
  163.     set value [string trimright $value]
  164.     if {[regexp {[][ @‘'“”:,({})-]} $value blah]} {
  165.         set quote 1
  166.     } else {
  167.         set quote 0
  168.     }
  169.     
  170.     set value [format "%-4.4s" $value]
  171.     
  172.     if {$quote} {
  173.         set value "'${value}'"        
  174.     } 
  175.     
  176.     return $value
  177. }
  178.  
  179. proc tclAE::build::objectProperty {process property object} {
  180.     return [tclAE::build::resultData $process core getd ---- \
  181.                   [tclAE::build::propertyObject $property $object]]
  182. }
  183.  
  184. # ◊◊◊◊ Builders ◊◊◊◊ #
  185.  
  186. proc tclAE::build::coercion {fromValue toType} {
  187.     set toType [tclAE::build::protect $toType]
  188.  
  189.     switch -- [string index $fromValue 0] {
  190.         "\{" { # value is record
  191.             return "${toType}${fromValue}"
  192.         }
  193.         "\[" { # value is list
  194.             set msg "Cannot coerce a list"
  195.             error $msg "" [list AEParse 16 $msg]
  196.         }
  197.         default {
  198.             return "${toType}(${fromValue})"
  199.         }
  200.     }
  201. }
  202.  
  203. ## 
  204.  # -------------------------------------------------------------------------
  205.  # 
  206.  # "tclAE::build::List" --
  207.  # 
  208.  #  Convert list 'l' to an AE list, i.e., "[l1, l2, l3, ...]".
  209.  #  "-as type" coerces elements to 'type' before joining.  
  210.  #  Set "-untyped" if the elements do not consist of AEDescriptors
  211.  # -------------------------------------------------------------------------
  212.  ##
  213. proc tclAE::build::List {l args} {
  214.     set opts(-as) ""
  215.     set opts(-untyped) 0
  216.     getOpts as
  217.     
  218.     if {[string length $opts(-as)] != 0} {
  219.         set out {}
  220.         foreach item $l {
  221.             lappend out [tclAE::build::$opts(-as) $item]
  222.         }
  223.     } elseif {!$opts(-untyped)} {
  224.         set out {}
  225.         foreach item $l {
  226.             lappend out [$item print]
  227.         }        
  228.     } else {
  229.         set out $l
  230.     }
  231.     
  232.     set out [join $out ", "]
  233.     return "\[$out\]"
  234. }
  235.  
  236. ## 
  237.  # -------------------------------------------------------------------------
  238.  # 
  239.  # "tclAE::build::hexd" --
  240.  # 
  241.  #  Convert 'value' to '«value»'.
  242.  #  value's spaces are stripped and it is left-padded with 0 to even digits.
  243.  # -------------------------------------------------------------------------
  244.  ##
  245. proc tclAE::build::hexd {value} {
  246.     set newval $value
  247.     if {[expr {[string length $newval] % 2}]} {
  248.         # left pad with zero to make even number of digits
  249.         set newval "0${newval}"
  250.     } 
  251.     if {![is::Hexadecimal $newval]} {
  252.         set msg "Non-hex-digit in «${value}»" 
  253.         error $msg "" [list AECoerce 6 $msg]
  254.     } else {
  255.         return "«${newval}»"
  256.     }
  257. }
  258.  
  259. proc tclAE::build::_ensureBinary {text} {
  260.     if {[set len [string length $text]] > 0
  261.     &&    ([expr {[string length $text] % 2}] != 0
  262.         ||    ![is::Hexadecimal $text])} {
  263.         set text [coerce TEXT $text -x TEXT]
  264.     } else {
  265.         return $text
  266.     }
  267. }
  268.  
  269. ## 
  270.  # -------------------------------------------------------------------------
  271.  # 
  272.  # "tclAE::build::bool" --
  273.  # 
  274.  #  Convert 'val' to AE 'bool(«val»)'.
  275.  # -------------------------------------------------------------------------
  276.  ##
  277. proc tclAE::build::bool {val} {
  278.     if {$val} {
  279.         set val 1
  280.     } else {
  281.         set val 0
  282.     }
  283.     
  284.     return [tclAE::build::coercion [tclAE::build::hexd $val] bool]
  285. }
  286.  
  287. ## 
  288.  # -------------------------------------------------------------------------
  289.  # 
  290.  # "tclAE::build::TEXT" --
  291.  #  
  292.  #  Convert $txt to “TEXT”.
  293.  #  If there are curly quotes in $txt, output in raw hex, coerced to TEXT
  294.  # -------------------------------------------------------------------------
  295.  ##
  296. proc tclAE::build::TEXT {txt} {
  297.     if {$txt == ""} {
  298.         return "[tclAE::build::coercion {} TEXT]"
  299.     } elseif {[string first "\x00" $txt] >= 0
  300.     ||  [string first "“" $txt]    >= 0
  301.     ||  [string first "”" $txt]    >= 0} {
  302.         
  303.         set hexd [binary format "a*" $txt]
  304.         return "[tclAE::build::coercion [tclAE::build::hexd $hexd] TEXT]"
  305.     } else {
  306.         return "“${txt}”"
  307.     }
  308. }
  309.  
  310. ## 
  311.  # -------------------------------------------------------------------------
  312.  # 
  313.  # "tclAE::build::alis" --
  314.  # 
  315.  #  Convert 'path' to an alis(«...»).
  316.  # -------------------------------------------------------------------------
  317.  ##
  318. proc tclAE::build::alis {path} {
  319.     set alisDesc [tclAE::coerceData TEXT $path alis]
  320.     set gizmo [tclAE::print $alisDesc]
  321.     tclAE::disposeDesc $alisDesc
  322.     return $gizmo
  323. }
  324.  
  325. ## 
  326.  # -------------------------------------------------------------------------
  327.  # 
  328.  # "tclAE::build::fss" --
  329.  # 
  330.  #  Convert 'path' to an 'fss '(«...»).
  331.  # -------------------------------------------------------------------------
  332.  ##
  333. proc tclAE::build::fss {path} {
  334.     set fss [tclAE::build::resultDesc 'MACS' core getd \
  335.       ---- "obj{want:type('cobj'), from:'null'(), \
  336.         [tclAE::build::name $path] \
  337.       }" \
  338.       rtyp fss \
  339.     ]
  340.   set result [tclAE::print $fss]
  341.   tclAE::disposeDesc $fss
  342.   
  343.   return $result
  344. }
  345.  
  346. ## 
  347.  # -------------------------------------------------------------------------
  348.  # 
  349.  # "tclAE::build::ident" --
  350.  # 
  351.  #  Dummy proc for rebuilding AEGizmos strings from parsed lists
  352.  # -------------------------------------------------------------------------
  353.  ##
  354. proc tclAE::build::enum {enum} {
  355.     return [tclAE::build::protect $enum]
  356. }
  357.  
  358.  
  359. proc tclAE::build::name {name} {
  360.     return "form:'name', seld:[tclAE::build::TEXT $name]"
  361. }
  362.  
  363. proc tclAE::build::filename {name} {
  364.     return "obj{want:type('file'), from:'null'(), [tclAE::build::name $name] } "
  365. }
  366.  
  367. proc tclAE::build::winByName {name} {
  368.     return "obj{want:type('cwin'), from:'null'(), [tclAE::build::name $name]}"
  369. }
  370.  
  371. proc tclAE::build::winByPos {absPos} {
  372.     return "obj{want:type('cwin'), from:'null'(), [tclAE::build::absPos $absPos]}"
  373. }
  374.  
  375. proc tclAE::build::lineRange {absPos1 absPos2} {
  376.     set lineObj1 "obj{want:type('clin'), from:'ccnt'(), [tclAE::build::absPos $absPos1]}"
  377.     set lineObj2 "obj{want:type('clin'), from:'ccnt'(), [tclAE::build::absPos $absPos2]}"
  378.     return "form:'rang', seld:rang{star:$lineObj1, stop:$lineObj2}"
  379. }
  380.  
  381. proc tclAE::build::absPos {posName} {
  382.     #
  383.     # Use '1' or 'first' to specify first position
  384.     # and '-1' or 'last' to specify last position.
  385.     #
  386.     if {$posName == "first"} { 
  387.         set posName 1 
  388.     } elseif {$posName == "last"} { 
  389.         set posName -1 
  390.     }
  391.     if {[is::Integer $posName]} {
  392.         return "form:indx, seld:long($posName)"
  393.     } else {
  394.         error "tclAE::build::absPos: bad argument"
  395.     }
  396. }
  397.  
  398. proc tclAE::build::nullObject {} { 
  399.     return "'null'()" 
  400. }
  401.  
  402. proc tclAE::build::objectType {type} { 
  403.     return "type($type)" 
  404. }
  405.  
  406. proc tclAE::build::nameObject {type name {from ""}}     {
  407.     if {$from == ""} {
  408.         set from [tclAE::build::nullObject]
  409.     } 
  410.     return "obj \{ \
  411.       form:name, \
  412.       want:[tclAE::build::objectType $type], \
  413.       seld:$name, \
  414.       from:$from \
  415.     \}" 
  416. }
  417.  
  418. proc tclAE::build::indexObject {type ind {from ""}} {
  419.     if {$from == ""} {
  420.         set from [tclAE::build::nullObject]
  421.     } 
  422.     return "obj \{ \
  423.       form:indx, \
  424.       want:[tclAE::build::objectType $type], \
  425.       seld:$ind, \
  426.       from:$from \
  427.     \}" 
  428. }
  429.  
  430. proc tclAE::build::rangeObject {type absPos1 absPos2 {from ""}} {
  431.     if {$from == ""} {
  432.         set from [tclAE::build::nullObject]
  433.     } 
  434.     set type [tclAE::build::objectType $type]
  435.     
  436.     set obj1 "obj{                      \
  437.         want:$type,                     \
  438.         from:'ccnt'(),                  \
  439.         [tclAE::build::absPos $absPos1] \
  440.     }"
  441.     set obj2 "obj{                      \
  442.         want:$type,                     \
  443.         from:'ccnt'(),                  \
  444.         [tclAE::build::absPos $absPos2] \
  445.     }"
  446.     return "obj {     \
  447.       form:rang,      \
  448.       want:$type,     \
  449.       seld:rang{      \
  450.         star:$obj1,   \
  451.         stop:$obj2    \
  452.       },              \
  453.       from:$from      \
  454.     }" 
  455. }
  456.  
  457. proc tclAE::build::propertyObject {prop object} { 
  458.     return "obj \{\
  459.       form:prop, \
  460.       want:[tclAE::build::objectType prop], \
  461.       seld:[tclAE::build::objectType $prop], \
  462.       from:$object \
  463.     \}" 
  464. }
  465.  
  466. # ◊◊◊◊ Utilities ◊◊◊◊ #
  467.  
  468. ## 
  469.  # -------------------------------------------------------------------------
  470.  # 
  471.  # "tclAE::build::startupDisk" --
  472.  # 
  473.  #  The name of the Startup Disk (as sometimes returned by the Finder)
  474.  # -------------------------------------------------------------------------
  475.  ##
  476. proc tclAE::build::startupDisk {} {
  477.     return [tclAE::build::objectProperty 'MACS' pnam \
  478.       "obj \{want:type(prop), from:'null'(), \
  479.       form:prop, seld:type(sdsk)\}" \
  480.     ]    
  481. }
  482.  
  483. ## 
  484.  # -------------------------------------------------------------------------
  485.  # 
  486.  # "tclAE::build::OS8userName" --
  487.  # 
  488.  # Get the owner name of the computer
  489.  #  
  490.  # -------------------------------------------------------------------------
  491.  ##
  492. proc tclAE::build::OS8userName {} {
  493.     # tell application "Finder" to get owner name
  494.     return [tclAE::build::resultData 'MACS' ownn getd]
  495. }
  496.  
  497. ## 
  498.  # -------------------------------------------------------------------------
  499.  # 
  500.  # "tclAE::build::OS7userName" --
  501.  # 
  502.  # For MacOS 7.x, we use the owner of the preferences folder.
  503.  #  
  504.  # This is not guaranteed to be the same as the Mac's owner, but it's 
  505.  # likely the same and seems preferable to IC's user name, which is almost 
  506.  # never the same.
  507.  #
  508.  # I picked the preference folder because it was easily 
  509.  # specifiable through AppleEvents, because its default ownership 
  510.  # is that of the computer, and because a user would really have to 
  511.  # go out of their way to change it (by either explicitly changing 
  512.  # ownership, or more likely, by clicking 
  513.  # 'Make all currently enclosed folders like this one' 
  514.  # in the startup disk's Sharing window after changing the disk's 
  515.  # ownership. Anyone who does this should be taunted severely.
  516.  # 
  517.  # This will fail if File Sharing is off.
  518.  # -------------------------------------------------------------------------
  519.  ##
  520. proc tclAE::build::OS7userName {} {
  521.     # tell application "Finder" to get owner of preferences folder
  522.     return [tclAE::build::objectProperty 'MACS' sown \
  523.       [tclAE::build::propertyObject pref [tclAE::build::nullObject]] \
  524.     ]
  525. }
  526.  
  527. ## 
  528.  # -------------------------------------------------------------------------
  529.  # 
  530.  # "tclAE::build::userName" --
  531.  # 
  532.  #  Return the default user name. The Mac's owner name,
  533.  #  which is in String Resource ID -16096, is inaccesible to Tcl 
  534.  #  (at least until Tcl 8 is implemented).
  535.  #  
  536.  #  Try different mechanisms for determining the user name.
  537.  #  
  538.  # -------------------------------------------------------------------------
  539.  ##
  540. if {[info tclversion] < 8.0} {
  541.     proc tclAE::build::userName {} {
  542.         
  543.         if {[catch {tclAE::build::OS8userName} userName]} {
  544.             
  545.             # Above failed, probably because the OS doesn't support
  546.             # scriptable File Sharing.
  547.             
  548.             if {[catch {tclAE::build::OS7userName} userName]} {
  549.                 # Both attempts at a user name failed, so return whatever
  550.                 # Internet Config has
  551.                 
  552.                 set userName [icGetPref RealName]
  553.             }
  554.         }
  555.         
  556.         return $userName
  557.     }
  558. } else {
  559.     ;proc tclAE::build::userName {} {
  560.         return [text::fromPstring [resource read "STR " -16096]]
  561.     }
  562. }
  563.